home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / 1svga / lookc1.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-05-29  |  5.2 KB  |  168 lines
  1. { Look Chn/Eng Text/640x480,16 Colors }
  2.  
  3. uses Dos,Txt,VGA16;
  4.  
  5. var Texts:array[0..15000] of ^string;
  6.     LineMax:integer;
  7.     DirInfo:SearchRec;
  8.     Dir:DirStr; Name:NameStr; Ext:ExtStr;
  9.     Font,FontAsc,FontSpc,FontSup:pointer;
  10.     FileChn:string;      { 3840,12240,10950 bytes }
  11.  
  12. { ─────────────── InitChinese ─────────────── }
  13. procedure InitChinese(Chn,Asc,Spc,Sup:string);
  14. begin
  15.   if (FileLen(Asc,1)<0) then
  16.     begin Writeln; Writeln(''''+Asc+''' not found !'); Halt(1); end;
  17.   if (FileLen(Spc,1)<0) then
  18.     begin Writeln; Writeln(''''+Spc+''' not found !'); Halt(1); end;
  19.   if (FileLen(Sup,1)<0) then
  20.     begin Writeln; Writeln(''''+Sup+''' not found !'); Halt(1); end;
  21.   FileChn:=Chn;
  22.   GetMem(FontAsc,3840);  FileRead(Asc,0,256,15,FontAsc^);
  23.   GetMem(FontSpc,12240); FileRead(Spc,0,408,30,FontSpc^);
  24.   GetMem(FontSup,10950); FileRead(Sup,0,365,30,FontSup^);
  25. end;
  26. { ─────────────── PrintC ─────────────── }
  27. procedure PrintC(X,Y,Color,BkColor:integer;St:string);
  28. var Buf,Buf2:array[0..239] of byte;
  29.     S1,O1,S2,O2,S3,O3,I,Hi,Lo,N,L,P:integer;
  30.     C:word;
  31.     File1:file;
  32. begin
  33.   S1:=Seg(FontAsc^); O1:=Ofs(FontAsc^);
  34.   S2:=Seg(FontSpc^); O2:=Ofs(FontSpc^);
  35.   S3:=Seg(FontSup^); O3:=Ofs(FontSup^);
  36.   Assign(File1,FileChn); Reset(File1,30);
  37.   L:=Length(St); P:=0;
  38.   while P<L do begin
  39.     Hi:=Ord(St[P+1]); Lo:=Ord(St[P+2]); C:=Hi shl 8+Lo;
  40.     case C of
  41.       $A440..$C67E,$C940..$F9FE:begin
  42.     if Lo>$7E then Dec(Lo,34);
  43.     N:=157*(Hi-$A4)+Lo-$40;    if N>5400 then Dec(N,408);
  44.     if N<13094 then begin Seek(File1,N); BlockRead(File1,Buf,1); end
  45.       else Move(Mem[S2:O2+2580],Buf,30);
  46.     if BkColor=0 then PutX(X,Y,16,15,Color,Buf) else begin
  47.       Conv1to4(Buf,Buf2,30,Color,BkColor);
  48.       Put(X,Y,16,15,Buf2);
  49.     end;
  50.     Inc(X,16); Inc(P,2);
  51.       end;
  52.       $A140..$A3BF:begin
  53.     if Lo>$7E then Dec(Lo,34);
  54.     N:=157*(Hi-$A1)+Lo-$40;
  55.     if BkColor=0 then PutX(X,Y,16,15,Color,Mem[S2:O2+30*N]) else begin
  56.       Conv1to4(Mem[S2:O2+30*N],Buf2,30,Color,BkColor);
  57.       Put(X,Y,16,15,Buf2);
  58.     end;
  59.     Inc(X,16); Inc(P,2);
  60.       end;
  61.       $C6A1..$C8FE:begin
  62.     N:=157*(Hi-$C6)+Lo-$A1;
  63.     if BkColor=0 then PutX(X,Y,16,15,Color,Mem[S3:O3+30*N]) else begin
  64.       Conv1to4(Mem[S3:O3+30*N],Buf2,30,Color,BkColor);
  65.       Put(X,Y,16,15,Buf2);
  66.     end;
  67.     Inc(X,16); Inc(P,2);
  68.       end else begin
  69.     if BkColor=0 then PutX(X,Y,8,15,Color,Mem[S1:O1+15*Hi]) else begin
  70.       Conv1to4(Mem[S1:O1+15*Hi],Buf2,15,Color,BkColor);
  71.       Put(X,Y,8,15,Buf2);
  72.     end;
  73.     Inc(X,8); Inc(P);
  74.       end;
  75.     end;
  76.   end;
  77.   Close(File1);
  78. end;
  79. { ─────────────── SetColor ─────────────── }
  80. procedure SetColor;
  81. const C:array[0..3] of byte=(104,80,54,30);
  82. var Pal:array[0..314] of byte;
  83.     Pal17:array[0..16] of byte;
  84.     I:integer;
  85. begin
  86.   VideoMode($13);
  87.   GetPalette(0,105,Pal);
  88.   SetMode(4);
  89.   for I:=0 to 3 do SetPalette(I,1,Pal[3*C[I]]);
  90.   SetPalette(4,12,Pal[64*I]);
  91.   for I:=0 to 15 do Pal17[I]:=I; Pal17[16]:=0;
  92.   SetPalette17(Pal17);
  93. end;
  94. { ─────────────── ReadTextFile ─────────────── }
  95. procedure ReadTextFile(Filename:string);
  96. var File1:text;
  97.     St:string;
  98.     I:integer;
  99. begin
  100.   Assign(File1,Filename); Reset(File1);
  101.   LineMax:=0;
  102.   while not Eof(File1) do begin
  103.     if (LineMax>15000) or (MemAvail<256) then begin Close(File1); Exit; end;
  104.     Readln(File1,St);
  105.     for I:=1 to 255 do if St[I]=#9 then
  106.       begin Delete(St,I,1); Insert('        ',St,I); end;
  107.     GetMem(Texts[LineMax],Length(St)+1);
  108.     Texts[LineMax]^:=St;
  109.     Inc(LineMax);
  110.   end;
  111.   Close(File1);
  112. end;
  113. { ─────────────── ShowPage ─────────────── }
  114. procedure ShowPage(X,Y:integer);
  115. var N,I,J:integer;
  116.     St:string[80];
  117. begin
  118.   if LineMax>24 then J:=24 else J:=LineMax;
  119.   for I:=0 to J-1 do begin
  120.     N:=Length(Texts[Y+I]^)-X;
  121.     if N<0 then N:=0; if N>80 then N:=80;
  122.     St[0]:=Chr(N); Move(Texts[Y+I]^[X+1],St[1],N);
  123.     PrintC(0,25+18*I,4+I shr 1,0,St);
  124.     Bar(N shl 3,25+18*I,(80-N) shl 3,15,0);
  125.   end;
  126. end;
  127. { ─────────────── Look ─────────────── }
  128. procedure Look;
  129. var X,Y,K:integer;
  130.     St:string[5];
  131. begin
  132.   FSplit(ParamStr(1),Dir,Name,Ext);
  133.   ReadTextFile(Dir+DirInfo.Name);
  134.   Bar(0,0,640,20,2); Bar(0,460,640,20,2);
  135.   PrintC(16,  2,3,2,'LookC V1.1  ññ¡^ñσÑ╗ñσ└╔╛\┼¬╡{ªí  (C) 1994 Jou-Nan Chen');
  136.   PrintC(16,462,3,2,'í⌠í⌡í≈í÷,PgUp,PgDn,Home,End-┬╜╛\Ñ╗ñσ   Esc-┬≈╢}');
  137.   X:=0; Y:=0; K:=0;
  138.   repeat
  139.     Bar(528,2,72,15,2);
  140.     Str(Y+1,St); PrintC(528,2,6,2,St);
  141.     Str(X+1,St); PrintC(576,2,6,2,St);
  142.     if (K<>$2166) and (K<>$2146) then ShowPage(X,Y);
  143.     K:=Key;
  144.     case K of
  145.       $4800:Dec(Y);     $5000:Inc(Y);        { Up,Down }
  146.       $4900:Dec(Y,24);  $5100:Inc(Y,24);     { PgUp,PgDn }
  147.       $4B00:Dec(X,20);  $4D00:Inc(X,20);     { Left,Right }
  148.       $4700:begin X:=0; Y:=0; end;           { Home }
  149.       $4F00:begin X:=0; Y:=LineMax-24; end;  { End }
  150.     end;
  151.     if Y>LineMax-24 then Y:=LineMax-24; if Y<0 then Y:=0;
  152.     if X>236 then X:=236; if X<0 then X:=0;
  153.   until K=$011B;    { Esc }
  154. end;
  155.  
  156. begin
  157.   if ParamCount=0 then
  158.     begin Writeln('Usage: Look Filename'); Halt(1); end;
  159.   if ParamCount=1 then begin
  160.     FindFirst(ParamStr(1),Archive,DirInfo);
  161.     if DosError<>0 then
  162.       begin Writeln('No such file !'); Halt(1); end;
  163.   end;
  164.   InitChinese('\et3\stdfont.15','\et3\ascfont.15','\et3\spcfont.15',
  165.     '\et3\spcfsupp.15');
  166.   SetColor; Look; SetMode(0);
  167. end.
  168.